;;; An experiment framework

(in-package :experiment)

(defun current-date ()
  "Return the current date and time as a formatted string."
  (multiple-value-bind (s min h d m y) (decode-universal-time (get-universal-time))
    (format nil "~2,'0d:~2,'0d:~2,'0d ~2,'0d/~2,'0d/~d" h min s d m y)))

(defgeneric dump-screen (experiment state))
(defgeneric handle-event (experiment event))

(defvar *experiment* nil
  "dynamically bound to the current experiment instance.")

(defclass experiment (gwee:switchable-layout)
  ((id :initarg :id :accessor experiment-id)
   (reward :initform 0 :initarg :reward :accessor reward)
   (log-file :initarg :log-file :accessor experiment-log-file)
   (log-stream :initform nil :accessor log-stream)
   (event-file :initarg :event-file :accessor experiment-event-file)
   (event-stream :initform nil :accessor event-stream)
   (suspend-file :initarg :suspend-file :accessor experiment-suspend-file)
   (state-stack :initform nil :accessor state-stack)
   (start-time :accessor experiment-start-time)
   (disable-timers-p :initform nil :accessor experiment-disable-timers-p :documentation
"Models don't want timers interfering with their state. So set this to
T and let the model advance the timers manually.")
;;    (state-stack :initform nil :accessor experiment-state-stack)
;;    (state-tree :initform nil :accessor experiment-state-tree)
   (global-data :initform (make-hash-table)))
  )

(defgeneric current-state (experiment))
(defgeneric parent-state (experiment))
(defgeneric restore-experiment (experiment))
(defgeneric save-experiment (experiment))
(defgeneric dump-experiment-slots (experiment)
  (:method-combination append :most-specific-last))
(defgeneric global-data (experiment key))
(defgeneric (setf global-data) (value experiment key))

(defmethod current-state ((exp experiment))
  (first (state-stack exp)))

(defmethod parent-state ((exp experiment))
  (second (state-stack exp)))

(defmethod dump-experiment-slots append ((exp experiment))
  `(:reward ,(reward exp)))

(defmethod save-experiment ((exp experiment))
  (unless *skip-log-file*
    (with-open-file (s (experiment-suspend-file exp)
                       :direction :output
                       :if-exists :supersede
                       :if-does-not-exist :create)
      (let ((*print-right-margin* 120))
        (print `(,(type-of exp)
                  ,@(dump-experiment-slots exp)
                  :states ,(state-dump exp (car (last (state-stack exp)))))
               s)))))

(defmethod restore-experiment ((exp experiment))
  (with-open-file (s (experiment-suspend-file exp))
    (print `(reading suspend))
    (let ((e (read s)))
      (print `(reading done))
      (assert (and (listp e)
                   (eq (first e) 'experiment)))
      (prog1
          (getf (cdr e) :states)
        (remf (cdr e) :states)
        (print `(restore ,e))
        (apply 'reinitialize-instance exp (cdr e))
        (print `(grr ,(reward exp)))))))

(defmethod global-data ((exp experiment) key)
  (gethash key (slot-value exp 'global-data)))

(defmethod (setf global-data) (value (exp experiment) key)
  (setf (gethash key (slot-value exp 'global-data)) value))

(defmacro with-current-state ((exp state) &body body)
  `(progn
     (push ,state (state-stack ,exp))
     (unwind-protect
          (progn ,@body)
       (assert (eq (first (state-stack ,exp)) ,state))
       (pop (state-stack ,exp)))))

(defmethod handle-event (experiment event)
  (state-dispatch-event experiment (current-state experiment) event))

(defmacro dispatch-event-fn (experiment state event &rest args)
  (let ((junk (gensym "JUNK")))
    `(lambda (&rest ,junk)
       (declare (ignore ,junk))
       (state-dispatch-event ,experiment ,state
                             (make-instance ',event ,@args)))))

(defun wire-button (button source &key (exp *experiment*) (state (current-state exp)))
  (setf (gwee:click-callback button)
        (dispatch-event-fn exp state exp:click-event :source source)))

(defmethod gwee:key-press-event ((view experiment) key)
  (if (eq (gwee::key-sym key) :sdl-key-escape)
      (gwee:toggle-fullscreen)
      (state-dispatch-event view (current-state view)
			    (make-instance 'key-press-event :key key))))

(defmethod gwee:mouse-press-event ((view experiment) button x y)
  (or (call-next-method)
      (progn
        (state-dispatch-event view (current-state view)
                              (make-instance 'click-event :source (gwee:find-subview-at view x y) :x x :y y))
        t)))

(defun compile-experiment (experiment states)
  "If states is a function then call it with EXPERIMENT as an
argument. Sometimes generating the states depends on the subject ID."
  (when (functionp states)
    (setf states (funcall states experiment)))
  (if (> (length states) 1)
      (compile-state experiment 'subsequence states)
      (compile-state experiment (car (car states)) (cdr (car states)))))

(defun experiment-log-start (exp extra &key session (version "Unknown") options)
  (setf (experiment-start-time exp) (gwee:now))
  (log-event-start)
  (apply 'log exp 'start
         :id (experiment-id exp)
         :time (experiment-start-time exp)
         :date (current-date)
         :session session
         :version version
         (append (mapcan (lambda (o) (list (option-name o) (option-value o))) options)
                 extra)))

(defun experiment-close-streams (exp)
  (close-log-stream exp)
  (close-event-stream exp))

(defun experiment-log-end (exp &key session (version "Unknown"))
  (log exp 'end
       :id (experiment-id exp)
       :session session
       :version version)
  (experiment-close-streams exp))

(defstruct main-screen
  sessions options)

(defvar *main-screen* nil
  "Dynamically bound to the list of sessions and options available when in the main screen.")

(defun run-experiment (sessions &key resizable (title "Experiment") (version "Unknown" version-supplied) options options-callback startup-message (option-formatter 'identity) (login (make-instance 'login)) (width 1024) (height 768) (background (gwee:gray 255)) (foreground (gwee:gray 0)) (log-template "log-~a.txt") (event-template "events-~a.txt") log model-server start-callback)
  (unless version-supplied
    (warn "!!! No version was supplied !!!"))
  (when (and options (not options-callback))
    (warn "!!! No options callback !!!"))
  (gwee:with-gui (width height
                        :title title
                        :font "sans.ttf"
                        :background background
                        :foreground foreground
                        :resizable resizable
                        :event-hook 'event-hook)
    (when (read-only-fs-p)
      (gwee:display-message "You are running from a read-only file system so a log file will not be written."
                            :width 500)
      (sdl:fill-surface (gwee:gray 0))
      (gwee::update-display)
      (setf *skip-log-file* t))
    (when startup-message
      (gwee:display-message startup-message :width 500)
      (sdl:fill-surface (gwee:gray 0))
      (gwee::update-display))
    (when model-server
      (let ((ret (model-server:start)))
        (when (typep ret 'condition)
          (gwee:display-message (format nil "Failed to start model server: ~a" ret))
          (sdl:fill-surface (gwee:gray 0))
          (gwee::update-display))))
    ;; It's handy in sandbox modes to be able to jump back and do it
    ;; all over again.
    (loop
       (catch 'restart
         (gwee:cancel-all-timers)
         (setf (gwee:view-subviews gwee:*top-view*) nil)
         (multiple-value-bind (id session) (let ((*main-screen* (make-main-screen :sessions sessions :options options)))
                                             (get-subject-from-user login sessions options option-formatter))
           (when options
             (funcall options-callback options))
           (let ((*experiment* (make-instance 'experiment
                                              :id id
                                              :log-file (get-log-file id log-template)
                                              :event-file (get-event-file id event-template)
                                              :suspend-file (get-suspend-file id)
                                              :parent gwee:*top-view*
                                              :x 0 :y 0
                                              :width :maximum :height :maximum)))
             (let ((states (compile-experiment *experiment*
                                               (cond
                                                 ((eq session :resume)
                                                  (list (restore-experiment *experiment*)))
                                                 ((u:funcallable (second (assoc session sessions)))
                                                  (list (funcall (second (assoc session sessions)))))
                                                 (t
                                                  (cdr (assoc session sessions)))))))
               (unwind-protect
                    (progn
                      (experiment-log-start *experiment* log
                                            :options options
                                            :session session
                                            :version version)
                      (when start-callback
                        (funcall start-callback))
                      (state-run *experiment* states)
                      (experiment-log-end *experiment*
                                          :session session
                                          :version version))
                 (experiment-close-streams *experiment*))
               (gwee:dispatch-events))))))))
